home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / break.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  4.9 KB  |  150 lines
  1. ;;;; "break.scm" Breakpoints for debugging in Scheme.
  2. ;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'qp)
  21.  
  22. ;;;; BREAKPOINTS
  23.  
  24. ;;; Typing (init-debug) at top level sets up a continuation for
  25. ;;; breakpoint.  When (breakpoint arg1 ...) is then called it returns
  26. ;;; from the top level continuation and pushes the continuation from
  27. ;;; which it was called on breakpoint:continuation-stack.  If
  28. ;;; (continue) is later called, it pops the topmost continuation off
  29. ;;; of breakpoint:continuation-stack and returns #f to it.
  30.  
  31. (define breakpoint:continuation-stack '())
  32.  
  33. (define debug:breakpoint
  34.   (let ((call-with-current-continuation call-with-current-continuation)
  35.     (apply apply) (qpn qpn)
  36.     (cons cons) (length length))
  37.     (lambda args
  38.       (if (provided? 'trace) (print-call-stack (current-error-port)))
  39.       (apply qpn "BREAKPOINT:" args)
  40.       (let ((ans
  41.          (call-with-current-continuation
  42.           (lambda (x)
  43.         (set! breakpoint:continuation-stack
  44.               (cons x breakpoint:continuation-stack))
  45.         (debug:top-continuation
  46.          (length breakpoint:continuation-stack))))))
  47.     (cond ((not (eq? ans breakpoint:continuation-stack)) ans))))))
  48.  
  49. (define debug:continue
  50.   (let ((null? null?) (car car) (cdr cdr))
  51.     (lambda args
  52.       (cond ((null? breakpoint:continuation-stack)
  53.          (display "; no break to continue from")
  54.          (newline))
  55.         (else
  56.          (let ((cont (car breakpoint:continuation-stack)))
  57.            (set! breakpoint:continuation-stack
  58.              (cdr breakpoint:continuation-stack))
  59.            (if (null? args) (cont #f)
  60.            (apply cont args))))))))
  61.  
  62. (define debug:top-continuation
  63.   (if (provided? 'abort)
  64.       (lambda (val) (display val) (newline) (abort))
  65.       (begin (display "; type (init-debug)") #f)))
  66.  
  67. (define (init-debug)
  68.   (call-with-current-continuation
  69.    (lambda (x) (set! debug:top-continuation x))))
  70.  
  71. (define breakpoint debug:breakpoint)
  72. (define bkpt debug:breakpoint)
  73. (define continue debug:continue)
  74.  
  75. (define breakf
  76.   (let ((null? null?)            ;These bindings are so that
  77.     (not not)            ;breakf will not break on parts
  78.     (car car) (cdr cdr)        ;of itself.
  79.     (eq? eq?) (+ +) (zero? zero?) (modulo modulo)
  80.     (apply apply) (display display) (breakpoint debug:breakpoint))
  81.     (lambda (function . optname)
  82.       ;; (set! trace:indent 0)
  83.       (let ((name (if (null? optname) function (car optname))))
  84.     (lambda args
  85.       (cond ((and (not (null? args))
  86.               (eq? (car args) 'debug:unbreak-object)
  87.               (null? (cdr args)))
  88.          function)
  89.         (else
  90.          (breakpoint name args)
  91.          (apply function args))))))))
  92.  
  93. ;;; the reason I use a symbol for debug:unbreak-object is so
  94. ;;; that functions can still be unbreaked if this file is read in twice.
  95.  
  96. (define (unbreakf function)
  97.   ;; (set! trace:indent 0)
  98.   (function 'debug:unbreak-object))
  99.  
  100. ;;;;The break: functions wrap around the debug: functions to provide
  101. ;;; niceties like keeping track of breakd functions and dealing with
  102. ;;; redefinition.
  103.  
  104. (require 'alist)
  105. (define break:adder (alist-associator eq?))
  106. (define break:deler (alist-remover eq?))
  107.  
  108. (define *breakd-procedures* '())
  109. (define (break:breakf fun sym)
  110.   (cond ((not (procedure? fun))
  111.      (display "WARNING: not a procedure " (current-error-port))
  112.      (display sym (current-error-port))
  113.      (newline (current-error-port))
  114.      (set! *breakd-procedures* (break:deler *breakd-procedures* sym))
  115.      fun)
  116.     (else
  117.      (let ((p (assq sym *breakd-procedures*)))
  118.        (cond ((and p (eq? (cdr p) fun))
  119.           fun)
  120.          (else
  121.           (let ((tfun (breakf fun sym)))
  122.             (set! *breakd-procedures*
  123.               (break:adder *breakd-procedures* sym tfun))
  124.             tfun)))))))
  125.  
  126. (define (break:unbreakf fun sym)
  127.   (let ((p (assq sym *breakd-procedures*)))
  128.     (set! *breakd-procedures* (break:deler *breakd-procedures* sym))
  129.     (cond ((not (procedure? fun)) fun)
  130.       ((not p) fun)
  131.       ((eq? (cdr p) fun)
  132.        (unbreakf fun))
  133.       (else fun))))
  134.  
  135. ;;;; Finally, the macros break and unbreak
  136.  
  137. (defmacro break xs
  138.   (if (null? xs)
  139.       `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x)))
  140.              (map car *breakd-procedures*))
  141.           (map car *breakd-procedures*))
  142.       `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) xs))))
  143. (defmacro unbreak xs
  144.   (if (null? xs)
  145.       (slib:eval
  146.        `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x)))
  147.               (map car *breakd-procedures*))
  148.            '',(map car *breakd-procedures*)))
  149.       `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x))) xs))))
  150.